Attribute VB_Name = "PSG"
Option Explicit

Dim PSG_Step_Table(0 To 1023) As Long
Dim PSG_Volume_Table(0 To 15) As Long
Dim PSG_Noise_Step_Table(0 To 3) As Long

Public Const MASTER_CLOCK = 3546893 '3579545

Public Const PI = 3.14159265358979
Public Const MAX_OUTPUT = &HFF '&h4fff
Public Const W_NOISE = &H12000 '&H12000
Public Const P_NOISE = &H8000 '&H8000
Public Const NOISE_DEF = &H4000 '&H4000

Public Mutey As Boolean 'for mute
Public CurrentSampleRate As Integer 'for sample rates

Public Const WAVE_MAPPER = -1&
Public Const CALLBACK_NULL = &H0        '  no callback
Public Const MMSYSERR_NOERROR = 0  '  no error
Public Const GMEM_FIXED = &H0
Public Const GMEM_ZEROINIT = &H40

Private OnBits(0 To 31) As Long

Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hmem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long

Public Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Public Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutGetErrorText Lib "winmm.dll" Alias "waveOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long
Public Declare Function waveOutMessage Lib "winmm.dll" (ByVal hWaveOut As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Public Declare Function waveOutOpen Lib "winmm.dll" (LPHWAVEOUT As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMAT, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function waveOutPause Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutRestart Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Public Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long

Type PSG
  Current_Channel As Long
  Current_Register As Long
  Register(0 To 7) As Long
  counter(0 To 3) As Long
  CntStep(0 To 3) As Long
  Volume(0 To 3) As Long
  Noise_Type As Long
  Noise As Long
End Type

Public PSG As PSG
Public Function pow(X As Long, Y As Long)
  pow = X ^ Y
End Function

Sub psg_init(ByVal clock As Long, ByVal rate As Long)

  Dim i, j As Integer, out As Double
  
  For i = 1 To 1023 ' Step calculation
    out = CDbl(clock) / CDbl(lshiftlong(i, 4))      ' out = frequency
    'out = CDbl(clock) / CDbl(ShiftLeft(i, 4))      ' out = frequency
    out = out / CDbl(rate)
    out = out * 65536#
    PSG_Step_Table(i) = CLng(out)
  Next i
  
  PSG_Step_Table(0) = PSG_Step_Table(1)
  
  For i = 0 To 2
    out = CDbl(clock) / CDbl(lshiftlong(1, (9 + i)))
    'out = CDbl(clock) / CDbl(ShiftLeft(1, (9 + i)))
    out = out / CDbl(rate)
    out = out * 65536#
    PSG_Noise_Step_Table(i) = CLng(out)
  Next i
  
  PSG_Noise_Step_Table(3) = 0
  
  out = CDbl(MAX_OUTPUT / 3#)
  
  For i = 0 To 14
    PSG_Volume_Table(i) = CLng(out)
    out = out / 1.258925412        ' = 10 ^ (2/20) = 2dB
  Next i
  
  PSG_Volume_Table(15) = 0
  
  psg_reset

End Sub
Sub psg_reset()
  
  Dim i As Integer
  
  PSG.Current_Register = 0
  PSG.Current_Channel = 0
  PSG.Noise = 0
  PSG.Noise_Type = 0
  
  For i = 0 To 3
    PSG.Volume(i) = 0
    PSG.counter(i) = 0
    PSG.CntStep(i) = 0
  Next i
    
End Sub
Sub psg_write(ByVal data As Integer)
    
  If Mutey = True Then Exit Sub
    
  If (data And &H80) Then
    
    PSG.Current_Register = rshiftlong((data And &H70), 4)
    PSG.Current_Channel = rshiftlong(PSG.Current_Register, 1)
    'PSG.Current_Register = ShiftRight((data And &H70), 4)
    'PSG.Current_Channel = ShiftRight(PSG.Current_Register, 1)
    data = data And &HF
    
    PSG.Register(PSG.Current_Register) = (PSG.Register(PSG.Current_Register) And &H3F0) Or data
    
    If (PSG.Current_Register And 1) Then
    
      ' Volume
      PSG.Volume(PSG.Current_Channel) = PSG_Volume_Table(data)
      
    Else
    
      ' Frequency
      If (PSG.Current_Channel <> 3) Then
      
        'Normal channel
        PSG.CntStep(PSG.Current_Channel) = PSG_Step_Table(PSG.Register(PSG.Current_Register))
        
        If ((PSG.Current_Channel = 2) And ((PSG.Register(6) And 3) = 3)) Then
          PSG.CntStep(3) = rshiftlong(PSG.CntStep(2), 1)
          'PSG.CntStep(3) = ShiftRight(PSG.CntStep(2), 1)
        End If
        
      Else
      
        'Noise channel
        PSG.Noise = NOISE_DEF
        PSG_Noise_Step_Table(3) = rshiftlong(PSG.CntStep(2), 1)
        'PSG_Noise_Step_Table(3) = ShiftRight(PSG.CntStep(2), 1)
        PSG.CntStep(3) = PSG_Noise_Step_Table(data And 3)
        
        If (data And 4) Then
          PSG.Noise_Type = W_NOISE
        Else
          PSG.Noise_Type = P_NOISE
        End If
        
      End If
      
    End If
    
  Else
  
    If (Not (PSG.Current_Register And 1)) Then
      'Frequency
      If (PSG.Current_Channel <> 3) Then
      
        PSG.Register(PSG.Current_Register) = (PSG.Register(PSG.Current_Register) And &HF) Or lshiftlong((data And &H3F), 4)
        'PSG.Register(PSG.Current_Register) = (PSG.Register(PSG.Current_Register) And &HF) Or ShiftLeft((data And &H3F), 4)
        
        PSG.CntStep(PSG.Current_Channel) = PSG_Step_Table(PSG.Register(PSG.Current_Register))
        
        If ((PSG.Current_Channel = 2) And ((PSG.Register(6) And 3) = 3)) Then
          PSG.CntStep(3) = rshiftlong(PSG.CntStep(2), 1)
          'PSG.CntStep(3) = ShiftRight(PSG.CntStep(2), 1)
        End If
        
      End If
      
    End If
    
  End If

End Sub

Sub psg_update(ByRef buffer() As Byte, ByVal length As Integer)

  Dim i, j As Integer, output As Integer
  
  If Mutey = True Then Exit Sub
  
  For i = 0 To length - 1
    
    output = 0
    
    ' channel 0, 1, 2
    For j = 2 To 0 Step -1
      If (PSG.counter(j) And &H10000) Then
        output = output + PSG.Volume(j)
      End If
      PSG.counter(j) = PSG.counter(j) + PSG.CntStep(j)
    Next j
    
    'noise channel (3)
    If (PSG.Noise And 1) Then
      output = output + PSG.Volume(3)
      PSG.Noise = PSG.Noise Xor PSG.Noise_Type
    End If
    
    If (PSG.counter(3) And &H10000) Then
      PSG.counter(3) = PSG.counter(3) And &HFFFF
      PSG.Noise = rshiftlong(PSG.Noise, 1)
      'PSG.Noise = ShiftRight(PSG.Noise, 1)
    End If
    
    PSG.counter(3) = PSG.counter(3) + PSG.CntStep(3)
    
    'If output < 256 Then
      buffer(i) = output
    'Else
      'buffer(i) = 255
    'End If
    
  Next i
  
End Sub
Public Function lshiftlong(ByVal value As Long, ByVal Shift As Integer) As Long
  
  makeonbits
  
  If (value And (2 ^ (31 - Shift))) Then GoTo OverFlow
  
  lshiftlong = ((value And OnBits(31 - Shift)) * (2 ^ Shift))
  
  Exit Function
  
OverFlow:
  
  lshiftlong = ((value And OnBits(31 - (Shift + 1))) * (2 ^ (Shift))) Or &H80000000
  
End Function

Public Function rshiftlong(ByVal value As Long, ByVal Shift As Integer) As Long
  
  Dim hi As Long
  
  makeonbits
  
  If (value And &H80000000) Then hi = &H40000000
  
  rshiftlong = (value And &H7FFFFFFE) \ (2 ^ Shift)
  rshiftlong = (rshiftlong Or (hi \ (2 ^ (Shift - 1))))

End Function
 


Private Sub makeonbits()

  Dim j As Integer, v As Long
  
  For j = 0 To 30
    v = v + (2 ^ j)
    OnBits(j) = v
  Next j
  
  OnBits(j) = v + &H80000000
  
End Sub


Public Function initializewaveout() As Boolean
    
  Dim lRet As Long, sErrMsg As String, lCounter As Long, lCounter2 As Long
  'glBeeperVal = 128
  
  With gtWavFormat
    .wFormatTag = WAVE_FORMAT_PCM
    .nChannels = 1
    .nSamplesPerSec = WAVE_FREQUENCY
    .nAvgBytesPerSec = WAVE_FREQUENCY
    .nBlockAlign = 1
    .wBitsPerSample = 8
    .cbSize = 0
  End With
  
  lRet = waveOutOpen(glphWaveOut, WAVE_MAPPER, gtWavFormat, 0, True, CALLBACK_NULL)
  
  If lRet <> MMSYSERR_NOERROR Then
    sErrMsg = Space$(255)
    waveOutGetErrorText lRet, sErrMsg, Len(sErrMsg)
    sErrMsg = left$(sErrMsg, InStr(sErrMsg, Chr$(0)) - 1)
    MsgBox LCase("Error initialising WaveOut device.") & vbCrLf & vbCrLf & sErrMsg, vbOKOnly Or vbExclamation, "vbsms+"
    initializewaveout = False
    Exit Function
  End If
  
  For lCounter = 1 To NUM_WAV_BUFFERS
  
    ghMem(lCounter) = GlobalAlloc(GPTR, WAV_BUFFER_SIZE)
    gpMem(lCounter) = GlobalLock(ghMem(lCounter))
    
    With gtWavHdr(lCounter)
      .lpData = gpMem(lCounter)
      .dwBufferLength = WAV_BUFFER_SIZE
      .dwUser = 0
      .dwFlags = 0
      .dwLoops = 0
      .lpNext = 0
    End With
  
    lRet = waveOutPrepareHeader(glphWaveOut, gtWavHdr(lCounter), Len(gtWavHdr(lCounter)))
  
    If lRet <> MMSYSERR_NOERROR Then
      sErrMsg = Space$(255)
      waveOutGetErrorText lRet, sErrMsg, Len(sErrMsg)
      sErrMsg = left$(sErrMsg, InStr(sErrMsg, Chr$(0)) - 1)
      MsgBox LCase("Error preparing wave header.") & vbCrLf & vbCrLf & sErrMsg, vbOKOnly Or vbExclamation, "vbsms+"
      lRet = waveOutClose(glphWaveOut)
      For lCounter2 = 1 To NUM_WAV_BUFFERS
        Call GlobalUnlock(ghMem(lCounter2))
        Call GlobalFree(ghMem(lCounter2))
      Next lCounter2
      initializewaveout = False
      Exit Function
    End If
    
  Next lCounter
  
  For lCounter = LBound(sound_buffer) To UBound(sound_buffer)
    sound_buffer(lCounter) = 128
  Next lCounter
  
  initializewaveout = True

End Function
Public Sub samplerate(rate) 'sets the sample rate KHz
  
  CurrentSampleRate = rate
  
  Select Case rate
    Case 0: WAVE_FREQUENCY = 11025: WAV_BUFFER_SIZE = 220
    Case 1: WAVE_FREQUENCY = 22050: WAV_BUFFER_SIZE = 441
    Case 2: WAVE_FREQUENCY = 44100: WAV_BUFFER_SIZE = 882
  End Select

  ReDim sound_buffer(WAV_BUFFER_SIZE)

End Sub


